; File: EIGHTS.LSP  (c) 	    03/06/91		Soft WareHouse, Inc.


;		   * * *   The Eights Puzzle   * * *

; This program solves the Eights Puzzle using the ordered state-space
; search technique described in "Principles of Artificial Intelligence",
; by Nils J. Nilsson, 1980, Tioga Publishing Co., Palo Alto, CA; pp 85-88.
; It was originally written by Peter A. Harada of Honolulu, Hawaii.

; A hard starting position is:
;	3  4  1
;	2  8  7
;	   5  6

(DEFUN EIGHTS (
    *INTERRUPT-HOOK* *ROWS* *COLS*)
  (SETQ *ROWS* (THIRD (MAKE-WINDOW))
	*COLS* (FOURTH (MAKE-WINDOW)))
  ((EIGHTS-DISPLAY)
    (SET-CURSOR (SUB1 *ROWS*) 0)
    (WRITE-SENTENCE "Press any key to play or ESC to quit.")
    (CLEAR-INPUT)
    ((EQ (READ-BYTE) 27) NIL)
    (SET-CURSOR (SUB1 *ROWS*) 0)
    (SPACES 37)
    (LOOP
      (EIGHTS-PLAY)
      (SET-CURSOR (SUB1 *ROWS*) 0)
      ((NOT (Y-OR-N-P "Do you want to solve another one?")))
      (SET-CURSOR (SUB1 *ROWS*) 0)
      (SPACES 41) ) ) )

(DEFUN EIGHTS-PLAY (
    INIT-STATE USER-STATE SOLUTION BYTE
    *PROMPT-ROW* *PROMPT-COL* *AUTO-NEWLINE* *ROWS* *COLS*)
  (SETQ *AUTO-NEWLINE* T
	*ROWS* (THIRD (MAKE-WINDOW))
	*COLS* (FOURTH (MAKE-WINDOW)))
  ((NULL (EIGHTS-TRAY)))
  (SET-CURSOR 16 0)
  (SPACES 112)
  (SET-CURSOR 16 0)
  (WRITE-SENTENCE "Enter one of these numbers for this tile: ")
  (IF (< (- *COLS* (COLUMN)) 27)
      (TERPRI))
  (SETQ *PROMPT-ROW* (ROW)
	*PROMPT-COL* (COLUMN)
	INIT-STATE (MAKE-LIST 9))
  (WRITE-SENTENCE "1 2 3 4 5 6 7 8 or a space")
  (CATCH 'QUIT-EIGHTS
    (READ-TILE INIT-STATE 0)
    (READ-TILE INIT-STATE 1)
    (READ-TILE INIT-STATE 2)
    (READ-TILE INIT-STATE 7)
    (READ-TILE INIT-STATE 8)
    (READ-TILE INIT-STATE 3)
    (READ-TILE INIT-STATE 6)
    (READ-TILE INIT-STATE 5)
    (REPLACE-NTH (CAR (SET-DIFFERENCE *GOAL-STATE* INIT-STATE)) INIT-STATE 4)
    (DISPLAY-TILE (NTH 4 INIT-STATE) 4)
    (SET-CURSOR 16 0)
    (SPACES 112)
    (SET-CURSOR 16 0)
    ((NOT (SETQ USER-STATE (EIGHTS-MANUAL (COPY-LIST INIT-STATE)))) NIL)
    ( ((EQUAL USER-STATE *GOAL-STATE*)
	(DISPLAY-TILE (NTH 0 INIT-STATE) 0)
	(DISPLAY-TILE (NTH 1 INIT-STATE) 1)
	(DISPLAY-TILE (NTH 2 INIT-STATE) 2)
	(DISPLAY-TILE (NTH 7 INIT-STATE) 7)
	(DISPLAY-TILE (NTH 8 INIT-STATE) 8)
	(DISPLAY-TILE (NTH 3 INIT-STATE) 3)
	(DISPLAY-TILE (NTH 6 INIT-STATE) 6)
	(DISPLAY-TILE (NTH 5 INIT-STATE) 5)
	(DISPLAY-TILE (NTH 4 INIT-STATE) 4) )
      (SETQ INIT-STATE USER-STATE) )
    (SET-CURSOR 16 0)
    (CENTER "Paths checked so far:    ")
    (SETQ SOLUTION (EIGHTS-AUTO INIT-STATE))
    (SET-CURSOR 16 0)
    (CENTER "			      ")
    (SET-CURSOR 16 0)
    ((NULL SOLUTION))
    (CENTER (PACK* "My solution requires " (LENGTH SOLUTION) " moves."))
    (LOOP
      ((AND (LISTEN) (EQ (READ-BYTE) 27)))
      ((NULL SOLUTION))
      (EIGHTS-MOVE INIT-STATE (CAR SOLUTION))
      (TONE NIL 750)
      (SETQ INIT-STATE (POP SOLUTION)) ) ) )

(DEFUN EIGHTS-MANUAL (STATE
    BLANK TILE BYTE MOVES)
  (SET-CURSOR 16 0)
  (CENTER "Use arrow keys to slide tiles.")
  (SET-CURSOR 17 0)
  (WRITE-SENTENCE "Press the ENTER key when ready for the computer to try.")
  (SETQ MOVES 0)
  (LOOP
    (SETQ BYTE (READ-BYTE))
    (IF (AND (= BYTE 255) (LISTEN))
	(SETQ BYTE (- (READ-BYTE))) )
    ((EQ BYTE 27) NIL)
    ((EQ BYTE 13)
      (SET-CURSOR 16 0)
      (SPACES (SUB1 *COLS*))
      (SET-CURSOR 17 0)
      (SPACES 56)
      STATE )
    (SETQ BLANK (POSITION 9 STATE)
	  TILE (NTH BLANK (CDR (ASSOC BYTE '(
	      ((24 10 -80) . (NIL NIL NIL 2 3 8 7 0 1)) 	;Down arrow
	      ((5  11 -72) . (7 8 3 4 NIL NIL NIL 6 5)) 	;Up arrow
	      ((19 8  -75) . (1 2 NIL NIL NIL 4 5 8 3)) 	;Left arrow
	      ((4  12 -77) . (NIL 0 1 8 5 6 NIL NIL 7)))	;Right arrow
			MEMBER))))
    ( ((NOT TILE)
	(TONE 1000 100) )
      (SETQ POSN1 (COPY-LIST STATE))
      (REPLACE-NTH (NTH TILE STATE) STATE BLANK)
      (REPLACE-NTH 9 STATE TILE)
      (EIGHTS-MOVE POSN1 STATE)
      (INCQ MOVES)
      (SET-CURSOR 16 0)
      (IF (= MOVES 1) (SPACES (SUB1 *COLS*)))
      (CENTER (PACK* "You have made " MOVES " move"
		     (IF (= MOVES 1) ". " "s."))) ) ) )

(DEFUN EIGHTS-AUTO (STATE
    GOAL OPEN CLOSED NODEI NODEJ SUCCESSORS EXPANSIONS N TEMPOPEN COL)
  (SETQ GOAL *GOAL-STATE*
	N 0
	EXPANSIONS 0
	OPEN (LIST (LIST (F* STATE N) N STATE NIL))
	COL (- (COLUMN) 3) )
  (LOOP
    (SET-CURSOR (ROW) COL)
    (PRIN1 EXPANSIONS)
    ((AND (LISTEN) (EQ (READ-BYTE) 27)) NIL)
    (SETQ OPEN (APPEND TEMPOPEN OPEN)
	  NODEI (GET-MIN-NODE OPEN GOAL)
	  OPEN (DELETE NODEI OPEN 'EQUAL))
    (PUSH NODEI CLOSED)
    ((EQUAL (CADDR NODEI) GOAL)
      (RETURN-SOLUTION NODEI CLOSED) )
    (SETQ SUCCESSORS (EXPAND-NODE (CADDR NODEI))
	  N (ADD1 (CADR NODEI))
	  TEMPOPEN NIL)
    (LOOP
      ((NULL SUCCESSORS))
      (INCQ EXPANSIONS)
      (SETQ NODEJ (LIST (F* (CAR SUCCESSORS) N) N (CAR SUCCESSORS)
			(CADDR NODEI))
	    INOPEN (CONTAINED-INP OPEN NODEJ)
	    INCLOSED (CONTAINED-INP CLOSED NODEJ))
      ( ((AND (NULL INOPEN) (NULL INCLOSED))
	  (PUSH NODEJ TEMPOPEN) )
	((AND (NULL INOPEN) (< (CAR NODEJ) (CAR INCLOSED)))
	  (SETQ CLOSED (DELETE (GET-MIN-NODE CLOSED (CADDR NODEJ))
		CLOSED 'EQUAL))
	  (PUSH NODEJ TEMPOPEN) )
	((AND (NULL INCLOSED) (< (CAR NODEJ) (CAR INOPEN)))
	  (SETQ OPEN (DELETE (GET-MIN-NODE OPEN (CADDR NODEJ)) OPEN 'EQUAL))
	  (PUSH NODEJ TEMPOPEN) ) )
      (POP SUCCESSORS) ) ) )

(DEFUN RETURN-SOLUTION (LASTNODE LST
    LST1 SOLUTION)
  (LOOP
    (PUSH (CADDR LASTNODE) SOLUTION)
    (SETQ LST1 LST)
    (LOOP
      ((EQUAL (CAR (CDDDR LASTNODE)) (CADDR (CAR LST1)))
	(SETQ LASTNODE (CAR LST1)) )
      (POP LST1) )
    ((NULL (CAR (CDDDR LASTNODE)))
      SOLUTION ) ) )

(DEFUN CONTAINED-INP (LST NODE TEMP)
  (SETQ NODE (CADDR NODE))
  (LOOP
    ((NULL LST) NIL)
    (SETQ TEMP (POP LST))
    ((EQUAL (CADDR TEMP) NODE) TEMP) ) )

(DEFUN EXPAND-NODE (NODE)
  (MAPCAR 'XCHG-POS (NTH (POSITION 9 NODE) *MOVE-LIST*)) )

(DEFUN XCHG-POS (PAIR LST TEMP1 TEMP2)
  (SETQ LST (COPY-LIST NODE)
	TEMP1 (NTHCDR (CAR PAIR) LST)
	TEMP2 (NTHCDR (CADR PAIR) LST)
	TEMP (CAR TEMP2))
  (RPLACA TEMP2 (CAR TEMP1))
  (RPLACA TEMP1 TEMP)  LST )

(SETQ *GOAL-STATE* '(1 2 3 4 5 6 7 8 9))

(SETQ *MOVE-LIST* '(((0 1) (0 7))	  ((0 1) (1 2) (1 8))
		    ((1 2) (2 3))	  ((3 8) (2 3) (3 4))
		    ((4 5) (3 4))	  ((5 6) (4 5) (5 8))
		    ((5 6) (6 7))	  ((7 8) (0 7) (6 7))
		    ((7 8) (3 8) (1 8) (5 8)) ) )

(SETQ *POS-LIST* '((0 1 2 3 4 3 2 1 0)	  (1 0 1 2 3 2 3 2 0)
		   (2 1 0 1 2 3 4 3 0)	  (3 2 1 0 1 2 3 2 0)
		   (4 3 2 1 0 1 2 3 0)	  (3 2 3 2 1 0 1 2 0)
		   (2 3 4 3 2 1 0 1 0)	  (1 2 3 2 3 2 1 0 0)
		   (2 1 2 1 2 1 2 1 0) ) )

(DEFUN F* (LAYOUT N)
  (+ N (H* LAYOUT N)) )

(DEFUN H* (LAYOUT N PWEIGHT SWEIGHT)
  (SETQ PWEIGHT 1
	SWEIGHT 3)		; Adjustable weights
  (+ (* PWEIGHT (P* LAYOUT N)) (* SWEIGHT (S* LAYOUT N))))

(DEFUN P* (LAYOUT N SUM POSITION)
  (SETQ SUM 0
	POSITION *POS-LIST*)
  (LOOP
    ((NULL LAYOUT) SUM)
    (INCQ SUM (NTH (+ (POP LAYOUT) -1) (POP POSITION))) ) )

(DEFUN S* (LAYOUT N
    SUM NUM)
  (SETQ SUM 1)
  ( ((EQ (CAR LAYOUT) 9)
      (SETQ LAYOUT (COPY-LIST (CDR LAYOUT))) )
    ((EQ (CAR (LAST LAYOUT)) 9)
      (SETQ SUM 0
	    LAYOUT (COPY-LIST LAYOUT)) )
    (SETQ LAYOUT (REMOVE 9 LAYOUT)) )
  (RPLACA (LAST LAYOUT) (CAR LAYOUT))
  (LOOP
    (SETQ NUM (POP LAYOUT))
    ((NULL LAYOUT) SUM)
    ( ((EQ NUM 8)
	((EQ (CAR LAYOUT) 1))
	(INCQ SUM 2) )
      ((EQ (ADD1 NUM) (CAR LAYOUT)))
      (INCQ SUM 2) ) ) )

(DEFUN GET-MIN-NODE (NODE-LST CONSTANT
    MIN-NODE)
  (SETQ MIN-NODE (POP NODE-LST))
  (LOOP
    ((NULL NODE-LST) MIN-NODE)
    (SETQ NODE (POP NODE-LST))
    ((EQUAL (CADDR NODE) CONSTANT) NODE)
    ( ((> (CAR MIN-NODE) (CAR NODE))
	(SETQ MIN-NODE NODE) )
      ((AND (EQUAL (CAR MIN-NODE) (CAR NODE))
	    (> (CADR MIN-NODE) (CADR NODE)) )
	(SETQ MIN-NODE NODE) ) ) ) )

; SOLVABLE's algorthm is from "Mathematical Games and Pastimes"
; by A. P. Domoryad; Macmillan Co., 1964, Pgs 79-85.

(DEFUN SOLVABLE (LST
    FLAG)
  (MAPC '(LAMBDA (NUM) (DISORDER NUM LST)) LST)
  (EQ (NOT FLAG) (EVENP (POSITION 9 LST))) )

(DEFUN DISORDER (NUM LST)
  ((EQ NUM (CAR LST)))
  ((> (CAR LST) NUM)
    (SETQ FLAG (NOT FLAG))
    (DISORDER NUM (CDR LST)) )
  (DISORDER NUM (CDR LST)) )

(DEFUN READ-TILE (STATE TILE
    BYTE)
  (DISPLAY-TILE NIL TILE)
  (LOOP
    (CLEAR-INPUT)
    (SETQ BYTE (READ-BYTE))
    ((EQ BYTE 27)			    ;ESC key abort
      (DISPLAY-TILE 9 TILE)
      (THROW 'QUIT-EIGHTS) )
    (SETQ BYTE (IF (= BYTE 32) 9 (- BYTE 48)))
    ((AND (<= 1 BYTE 9)
	  (NOT (MEMBER BYTE STATE))
	  (OR (NOT (MEMBER TILE '(4 5 6)))
	      (= BYTE 9)
	      (AND (= TILE 6)
		   (OR (MEMBER 9 STATE)
		       (SOLVABLE (APPEND (FIRSTN 4 STATE)
					 (SET-DIFFERENCE *GOAL-STATE*
							 (CONS BYTE STATE))
					 (LIST BYTE)
					 (NTHCDR 7 STATE)))))
	      (AND (= TILE 5)
		   (OR (NOT (MEMBER 9 STATE))
		       (SOLVABLE (APPEND (FIRSTN 4 STATE)
					 (SET-DIFFERENCE *GOAL-STATE*
							 (CONS BYTE STATE))
					 (LIST BYTE)
					 (NTHCDR 6 STATE))))))))
    (TONE 1000 100) )
  (DISPLAY-TILE BYTE TILE)
  (SET-CURSOR *PROMPT-ROW* (+ *PROMPT-COL* (* 2 (SUB1 BYTE))))
  (SPACES (IF (EQ BYTE 9) 10 1))
  (REPLACE-NTH BYTE STATE TILE) )

(DEFUN EIGHTS-MOVE (POSN1 POSN2
    NUM)
  (SETQ NUM (POSITION 9 POSN2))
  (DISPLAY-TILE 9 NUM)
  (SETQ NUM (POSITION 9 POSN1))
  (DISPLAY-TILE (NTH NUM POSN2) NUM) )

(SETQ *COLOR-MONITOR* 0)

(DEFUN EIGHTS-DISPLAY (
    *ROWS* *COLS*)
  (SETQ *ROWS* (THIRD (MAKE-WINDOW))
	*COLS* (FOURTH (MAKE-WINDOW)))
  ( ((NUMBERP *COLOR-MONITOR*)
      (CLEAR-SCREEN)
      (TERPRI)
      (SETQ *COLOR-MONITOR* (Y-OR-N-P "Are you using a color monitor?")) ) )
  (CLEAR-SCREEN)
  (CENTER "The Eights Puzzle")
  (TERPRI 2)
  ((NULL (EIGHTS-TRAY))
    (WRITE-SENTENCE "Window too small to show Eights Puzzle.")
    NIL )
  (DISPLAY-TILE 1 0)
  (DISPLAY-TILE 2 1)
  (DISPLAY-TILE 3 2)
  (DISPLAY-TILE 8 7)
  (DISPLAY-TILE 9 8)
  (DISPLAY-TILE 4 3)
  (DISPLAY-TILE 7 6)
  (DISPLAY-TILE 6 5)
  (DISPLAY-TILE 5 4)
  (SET-CURSOR 16 0)
  (WRITE-SENTENCE "This program \"slides\" eight \"tiles\" that are ")
  (WRITE-SENTENCE "randomly arranged in a 3 by 3 \"tray\" into this ")
  (WRITE-SENTENCE "configuration.")
  T )

(DEFUN EIGHTS-TRAY (
    ROW COL CHAR-LIST FGC BGC)
  ((OR (< *ROWS* 19) (< *COLS* 38)) NIL)
  (SETQ ROW 2
	COL (- (TRUNCATE (ADD1 *COLS*) 2)
	       (IF (MEMBER (VIDEO-MODE) '(0 1 4 5)) 7 10))
	NUM (IF (MEMBER (VIDEO-MODE) '(0 1 4 5)) 3 5))
  ( ((EQ (CSMEMORY 855) 2)			;IBM PC?
      (SETQ CHAR-LIST '(218 196 194 191 179 195 197 180 192 193 217 32)
	    FGC (FOREGROUND-COLOR (IF (USE-COLOR) 4 15))
	    BGC (BACKGROUND-COLOR (IF (USE-COLOR) 3 0))))
    ((<= 9 (CSMEMORY 855) 10)			;NEC PC-9801 or Fujitsu?
      (SET-CURSOR 0 0)
      (MAPC 'WRITE-BYTE '(27 41 51))		;Select graphics mode
      (SETQ CHAR-LIST '(152 149 145 153 150 147 143 146 154 144 155 32)) )
    (SETQ CHAR-LIST '(32  45  45  32  124 124 43  124 32  45  32  32)) )
  (EIGHTS-TRAY-AUX 0 1	2 3)
  (EIGHTS-TRAY-AUX 4 11 4 4)
  (EIGHTS-TRAY-AUX 4 11 4 4)
  (EIGHTS-TRAY-AUX 4 11 4 4)
  (EIGHTS-TRAY-AUX 5 1	6 7)
  (EIGHTS-TRAY-AUX 4 11 4 4)
  (EIGHTS-TRAY-AUX 4 11 4 4)
  (EIGHTS-TRAY-AUX 4 11 4 4)
  (EIGHTS-TRAY-AUX 5 1	6 7)
  (EIGHTS-TRAY-AUX 4 11 4 4)
  (EIGHTS-TRAY-AUX 4 11 4 4)
  (EIGHTS-TRAY-AUX 4 11 4 4)
  (EIGHTS-TRAY-AUX 8 1	9 10)
  ( ((EQ (CSMEMORY 855) 2)			;IBM PC?
      (FOREGROUND-COLOR FGC)
      (BACKGROUND-COLOR BGC) )
    ((<= 9 (CSMEMORY 855) 10)			;NEC PC-9801 or Fujitsu?
      (SET-CURSOR 0 0)
      (MAPC 'WRITE-BYTE '(27 41 48)) ) )	;Select kanji mode
  T )

(DEFUN EIGHTS-TRAY-AUX (CHAR1 CHAR2 CHAR3 CHAR4)
  (SET-CURSOR ROW COL)
  (WRITE-BYTE (NTH CHAR1 CHAR-LIST))
  (WRITE-BYTE (NTH CHAR2 CHAR-LIST) NUM)
  (WRITE-BYTE (NTH CHAR3 CHAR-LIST))
  (WRITE-BYTE (NTH CHAR2 CHAR-LIST) NUM)
  (WRITE-BYTE (NTH CHAR3 CHAR-LIST))
  (WRITE-BYTE (NTH CHAR2 CHAR-LIST) NUM)
  (WRITE-BYTE (NTH CHAR4 CHAR-LIST))
  (INCQ ROW) )

(DEFUN DISPLAY-TILE (BYTE TILE
    ROW COL FGC BGC BLOCK-CHAR)
  ( ((EQ (CSMEMORY 855) 2)			;IBM PC?
      (SETQ BLOCK-CHAR 219
	    FGC (FOREGROUND-COLOR)
	    BGC (BACKGROUND-COLOR))
      ((NOT BYTE)
	(BACKGROUND-COLOR (LOGIOR BGC 8)) )	;Blink
      (FOREGROUND-COLOR 0)
      ((USE-COLOR)
	(BACKGROUND-COLOR (IF (EQ BYTE 9) 3 6)) )
      (BACKGROUND-COLOR (IF (EQ BYTE 9) 0 7)) )
    ((<= 9 (CSMEMORY 855) 10)			;NEC PC-9801 or Fujitsu?
      (SETQ BLOCK-CHAR 135)
      (SET-CURSOR 0 0)
      (MAPC 'WRITE-BYTE '(27 41 51))			;Select graphics mode
      ((NOT BYTE)
	(MAPC 'WRITE-BYTE '(27 91 48 59 53 109)) )	;Blink
      ((EQ BYTE 9))
      (MAPC 'WRITE-BYTE '(27 91 48 59 55 109)) )	;Inverse video
    ((NEQ BYTE 9)
      (SETQ BLOCK-CHAR 32) ) )
  (SETQ ROW (NTH TILE '(4 4 4 8 12 12 12 8 8))
	COL (TRUNCATE (SUB1 *COLS*) 2))
  (IF (MEMBER TILE '(0 6 7))
      (SETQ COL (- COL 2 (* 2 (COL-DELTA)))) )
  (IF (MEMBER TILE '(2 3 4))
      (SETQ COL (+ COL 2 (* 2 (COL-DELTA))) ) )
  (SET-CURSOR (SUB1 ROW) (- COL (COL-DELTA)))
  (WRITE-BYTE (IF BYTE 32 BLOCK-CHAR) (+ 1 (* 2 (COL-DELTA))))
  (SET-CURSOR ROW (- COL (COL-DELTA)))
  (WRITE-BYTE (IF BYTE 32 BLOCK-CHAR) (COL-DELTA))
  (WRITE-BYTE (IF BYTE (IF (EQ BYTE 9) 32 (+ BYTE 48)) BLOCK-CHAR))
  (WRITE-BYTE (IF BYTE 32 BLOCK-CHAR) (COL-DELTA))
  (SET-CURSOR (ADD1 ROW) (- COL (COL-DELTA)))
  (WRITE-BYTE (IF BYTE 32 BLOCK-CHAR) (+ 1 (* 2 (COL-DELTA))))
  (SET-CURSOR ROW COL)
  ((EQ (CSMEMORY 855) 2)			;IBM PC?
    (FOREGROUND-COLOR FGC)
    (BACKGROUND-COLOR BGC) )
  ((<= 9 (CSMEMORY 855) 10)			;NEC PC-9801 or Fujitsu
    (MAPC 'WRITE-BYTE '(27 41 48))		;Select kanji mode
    (MAPC 'WRITE-BYTE '(27 91 48 109)) ) )	;Normal video

(DEFUN COL-DELTA ()
  ((MEMBER (VIDEO-MODE) '(0 1 4 5)) 1)
  2 )

(DEFUN USE-COLOR ()
  (AND *COLOR-MONITOR* (MEMBER (VIDEO-MODE) '(0 1 2 3))) )

(DEFUN CENTER (MSG)
  (SET-CURSOR (ROW) (TRUNCATE (- (CADDDR (MAKE-WINDOW)) (LENGTH MSG)) 2))
  (WRITE-SENTENCE MSG) )

(DEFUN Y-OR-N-P (MSG
    CHAR)
  ( ((NULL MSG))
    (FRESH-LINE T)
    (WRITE-SENTENCE (PACK* MSG " (Y/N) ") T) )
  (CLEAR-INPUT T)
  (LOOP
    (SETQ CHAR (CHAR-UPCASE (ASCII (READ-BYTE T))))
    ((EQ CHAR 'Y) (WRITE-STRING CHAR T) T)
    ((EQ CHAR 'N) (WRITE-STRING CHAR T) NIL)
    (WRITE-BYTE 7 NIL T) ) )

(DEFUN WRITE-SENTENCE (SENTENCE
    INDEX COLS *AUTO-NEWLINE*)
  (SETQ COLS (CADDDR (MAKE-WINDOW)))
  (LOOP
    ((EQ SENTENCE ""))
    (SETQ INDEX (- COLS (COLUMN)))
    ((NULL (CHAR SENTENCE INDEX))
      (WRITE-STRING SENTENCE) )
    (LOOP
      ((EQ (CHAR SENTENCE INDEX) " ")
	(WRITE-LINE (SUBSTRING SENTENCE 0 (SUB1 INDEX)))
	(SETQ SENTENCE (STRING-LEFT-TRIM " " (SUBSTRING SENTENCE INDEX))) )
      ((ZEROP INDEX)
	((ZEROP (COLUMN))
	  (WRITE-LINE (SUBSTRING SENTENCE 0 (SUB1 COLS)))
	  (SETQ SENTENCE (STRING-LEFT-TRIM " " (SUBSTRING SENTENCE COLS))) )
	(TERPRI) )
      (DECQ INDEX) ) ) )

(PROGN ((GETD 'WINDOWS T))
       (CLOSE-INPUT-FILE (FIND "EIGHTS.LSP" (INPUT-FILES) 'FINDSTRING))
       (EIGHTS) )

(SETQ *INIT-WINDOW* "Eights")
(SETQ *WINDOW-TYPES* (SORT (ADJOIN "Eights" *WINDOW-TYPES*) 'STRING<))
(SETQ DRIVER 'WINDOWS)

(DEFUN "Eights" (COMMAND
    *ROWS* *COLS*)
  ((EQ COMMAND 'CREATE-WINDOW)
    (LIST "Eights") )
  ((EQ COMMAND 'CLOSE-WINDOW))
  (CURRENT-WINDOW)
  ((EQ COMMAND 'UPDATE-WINDOW)
    (EIGHTS-DISPLAY) )
  (EIGHTS-STATUS)
  (LOOP
    (EXECUTE-OPTION 'COMMAND *EIGHTS-OPTIONS*) ) )

(SETQ *EIGHTS-OPTIONS* '(
	("Go" . EIGHTS-RUN)
	("Options" . (
		("Color" . (
			("Menu" . SET-MENU-COLOR)
			("Work" . SET-WORK-COLOR) ))
		("Display" . SET-DISPLAY)
		("Execute" . GO-DOS) ))
	("Quit" . QUIT-PROGRAM)
	("Window" . CHANGE-WINDOW) ))

(DEFUN EIGHTS-RUN ()
  (SHOW-PROMPT "Press ESC for options")
  (CURRENT-WINDOW)
  (CURSOR-OFF)
  (EIGHTS-PLAY) )

(DEFUN EIGHTS-STATUS ()
  (CLEAR-STATUS "Eights")
  (WRITE-STRING "The Eights Puzzle") )

(PROGN
  (TERPRI)
  (WRITE-SENTENCE "Press the ESC key and open an \"Eights\" window ")
  (WRITE-SENTENCE "to play the Eights Puzzle.")
  (TERPRI) )
